home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / operation.t < prev    next >
Text File  |  1988-05-02  |  7KB  |  186 lines
  1. (herald operation
  2.         (env tsys (osys kernel)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;;; %OPERATION and friends
  28.  
  29. (define-integrable (operation? obj)
  30.   (and (extend? obj) (eq? (extend-header obj) *operation-template*)))
  31.  
  32. ;;; Create an operation.
  33.  
  34. (define (%operation default id h)
  35.   (let ((op (%make-extend *operation-template* %%operation-size)))
  36.     (set (%operation-default     op) default)
  37.     (set (%operation-id          op) id)
  38.     (set (%operation-handler     op) h)
  39.     op))
  40.  
  41. ;;; Say (RET procedure) to proceed from this error.
  42. ;;; The value returned will be the value of the call to the operation.
  43.  
  44. (define (no-default-method op args)
  45.   (error "operation not handled~%  ~s"
  46.      (cons (%operation-id op) args)))
  47.  
  48. (define (%massage-default default)
  49.   (cond ((extend? default) default)
  50.         (else nil)))
  51.  
  52. (define (join . objects)
  53.   (cond ((null? objects) (object nil))
  54.         ((null? (cdr objects)) (car objects))
  55.         ((null? (cddr objects)) (join2 (car objects) (cadr objects)))
  56.         (else (join2 (car objects) (apply join (cdr objects))))))
  57.  
  58. (define (join2 lhs rhs)
  59.   (cond ((joined? lhs)
  60.          (join2 (joined-lhs lhs) (join2 (joined-rhs lhs) rhs)))
  61.         (else 
  62.          (let ((j (%make-extend *join-template* 2)))
  63.            (set (joined-lhs j) lhs)
  64.            (set (joined-rhs j) rhs)
  65.            j))))
  66.  
  67. (define-integrable (joined? obj) 
  68.   (and (extend? obj) (eq? (extend-header obj) *join-template*)))
  69.  
  70. (define (*object proc handler)
  71.   (let ((b (%make-extend *bogus-entity-template* 2)))
  72.     (set (bogus-entity-procedure b) proc)
  73.     (set (bogus-entity-handler b) handler)
  74.     b))
  75.  
  76. (define-integrable (bogus-entity? obj) 
  77.   (and (extend? obj) (eq? (extend-header obj) *bogus-entity-template*)))
  78.  
  79. (define (%predicate id)
  80.   (%operation false
  81.               id
  82.               (join-methods handle-operation
  83.                 ((print-type-string self) "Predicate"))))
  84.  
  85. ;;; Must precede any DEFINE-OPERATION.
  86.  
  87. (define handle-operation
  88.   (object nil
  89.     ((identification self) (%operation-id self))
  90.     ((set-identification self id)
  91.           (if (not (%operation-id self))
  92.            (set (%operation-id self) id)))
  93.     ((default-method self) (%operation-default self))
  94.     ((get-loaded-file self)
  95.      (get-loaded-file (%operation-default self)))  
  96.     ((print-type-string self) "Operation")))
  97.  
  98. (define-operation (default-method op))
  99.  
  100.  
  101. ;;; SETTER and "settable operations."
  102.  
  103. (define (%settable-operation default id)
  104.   (%operation default
  105.               id
  106.               (let ((the-setter
  107.                      (%operation nil
  108.                                  (cons 'setter (cons id '()))
  109.                                  handle-operation)))
  110.                 (join-methods handle-operation
  111.                   ((setter op) the-setter)))))
  112.  
  113. ;;; Standard very-general-purpose operations
  114.  
  115. (define-operation (procedure? obj)
  116.   (cond ((bogus-entity? obj) 
  117.          (procedure? (bogus-entity-procedure obj)))
  118.         ((closure? obj) 
  119.          (fx> (template-nargs (extend-header obj)) 0))
  120.         (else nil)))
  121.  
  122. (define-operation (argspectrum obj)
  123.   (cond ((bogus-entity? obj)
  124.          (argspectrum (bogus-entity-procedure obj)))
  125.         ((procedure? obj)
  126.          (cons (fx- (template-nargs (extend-header obj)) 1)
  127.                (if (template-nary? (extend-header obj)) 't '())))
  128.         ((frame? obj)
  129.          (cons (fx-negate (fx+ (template-nargs (extend-header obj)) 1))
  130.                (if (template-nary? (extend-header obj)) 't '())))
  131.         (else
  132.          (error "(~S ~S): object not callable" 'argspectrum obj))))
  133.  
  134. (define (arglist->argspectrum z)        ; see EVAL, OBJECT
  135.   (iterate loop ((z z)
  136.                  (n 0))
  137.     (cond ((atom? z) (cons n (not (null? z))))
  138.           (else (loop (cdr z) (fx+ n 1))))))
  139.  
  140. (define-operation (set-identification obj id) nil)   ;do nothing by default
  141.  
  142. (define-operation (get-proc-name obj)
  143.   (cond ((template? obj)
  144.          (template-definer obj))
  145.         (else nil)))
  146.  
  147. (define identification
  148.   (operation (lambda (obj)
  149.                (cond ((bogus-entity? obj)
  150.                       (identification (bogus-entity-procedure obj)))
  151.                      ((and (closure? obj)
  152.                            ;++ (template-definer (extend-header obj))???
  153.                            (let* ((header (extend-header obj))
  154.                                   (offset (template-definer-vcell-offset header)))
  155.                              (and offset
  156.                                   (extend-elt (template-unit header) offset))))
  157.                       => (lambda (vcell)
  158.                            (if (eq? (vcell-contents vcell) obj)
  159.                                (vcell-id vcell)
  160.                                nil)))
  161.                      (else nil)))
  162.     ((setter self) set-identification)
  163.     ((identification self) 'identification)))
  164.  
  165. ;;; IMMUTABLE? - for making objects be read-only.
  166.  
  167. (define-settable-operation (mutable? obj))
  168.  
  169. (define set-mutable? (setter mutable?))
  170.  
  171. (define-operation (set-immutable obj)
  172.   (set-mutable? obj nil))
  173.  
  174. (define (immutable? obj) (not (mutable? obj)))
  175.  
  176. ;;; randomness
  177.  
  178. (define-operation (insert self obj))
  179. (define-operation (delete self obj))
  180. (define-operation (hash self))
  181. (define hashx hash)
  182. ;(define-operation (sort self))
  183.  
  184.  
  185.  
  186.